Ακολουθίες-Σειρές-Γινόμενα

Ακολουθίες

Σύγκλιση ακολουθίας


          Clear["Global`*"]
l = 1;
aa = 1;
a[n_] := aa*Sin[Pi*n/6]/n+l
e = 0.1;
sol1 := NSolve[a[n]==l+e, n,Reals];
maxSol1 := Length[sol1];
n01 := Floor[n/.sol1[[maxSol1]]]+1;
sol2 := NSolve[a[n]==l-e, n,Reals];
maxSol2 := Length[sol2];
n02 := Floor[n/.sol2[[maxSol2]]]+1;
n0 := Max[n01,n02]
nInf = 150;
pl1 := ListPlot[Table[{n,a[n]},{n,1,n0-1}], PlotStyle -> Green,Background-> Gray,Filling->Axis, PlotRange -> {{0,nInf},{0,1.1(aa+l)}}];
pl2 := ListPlot[Table[{n,a[n]},{n,n0,nInf}], PlotStyle -> Red,Background-> Gray,Filling->Axis, PlotRange -> {{0,nInf},{0,1.1(aa+l)}}];
l1 := Plot[l-e,{x,0,nInf}, PlotStyle -> {Black, Dashed, Thin}];
l2 := Plot[e+l,{x,0,nInf}, PlotStyle -> {Black, Dashed, Thin}];
Show[pl1,pl2,l1,l2]
e = 0.01;
Show[pl1,pl2,l1,l2]

Αναδρομικές ακολουθίες

#### Ορισμός


           Clear["Global`*"]
a[1] = 1
a[n_] := a[n] = (2 n)/(n - 1) + a[n - 1]
tableAn = Table[{n, a[n]}, {n, 1, 12}] // N;
TableForm[tableAn, 
 TableHeadings -> {None, {"n", 
    Subscript[a,n]}}]

#### Γράφημα König-Lemeray


            Clear["Global`*"]
n = 100; (* Αριθμός επαναλήψεων *)

koeningLemeray[a_, x0_] := 
  Module[{f, seq, p, colors}, 
  (*Εδώ ο τύπος της συνάρτησης*)
    f[x_] := Which[0<=x<=1/2,2x, 1/2<x<=1, 2(1 - x)];
      (*Εδώ ο τύπος της συνάρτησης*)
    seq = NestList[f, x0, n];
    p = Partition[seq, 2, 1];
    colors = ColorData["SunsetColors"] /@ 
      Rescale[Range[Length[p]], {1, Length[p]}]; (* Αντιστοίχιση χρωμάτων *)

    Plot[{Style[f[x], Red], Style[x, Blue]}, {x, 0,1}, 
      PlotRange -> All,Background -> Lighter[Gray],
      Epilog -> (Table[{Thick, Opacity[0.8], colors[[i]], 
          Line[{{p[[i, 1]], p[[i, 1]]}, {p[[i, 1]], p[[i, 2]]}, 
            {p[[i, 2]], p[[i, 2]]}}]}, {i, Length[p]}] // Flatten), 
      AxesLabel -> {Subscript["x","n"], Subscript["x","n+1"]}, 
      PlotLabel -> "cobweb plot", 
      ImageSize -> 500]];


            koeningLemeray[1+Sqrt[6], 251/954]

#### Γράφημα διακλάδωσης


             Clear["Global`*"]

logisticMap[r_, x_] := r x (1 - x)

(* Λιγότερες επαναλήψεις και μεγαλύτερο βήμα για τα r *)
bifurcationData = Flatten[
   Table[
    {r, #} & /@ NestList[logisticMap[r, #] &, RandomReal[], 500][[400 ;;]],
    {r, 2.8, 4, 0.001}], 1];

pl= ListPlot[bifurcationData, 
 PlotStyle -> Directive[PointSize[0.001], Opacity[1]], 
 AxesLabel -> {"λ", "b"}, 
 AxesStyle -> White,          (* Αλλάζει το χρώμα των αξόνων σε λευκό *)
 TicksStyle -> White,         (* Αλλάζει το χρώμα των ticks σε λευκό *)
 ImageSize -> Large, 
 PlotRange -> {{2.8, 4}, {0, 1}}, 
 ColorFunction -> (ColorData["DarkRainbow"][#2] &), 
 Background -> Black, 
 ColorFunctionScaling -> True]

#### Τεστ 0-1 ##### Εξαγωγή $K_c$ Ακολουθία προς μελέτη.


                Clear["Global`*"]
λ=3.5;	
x[0] = 0.123;
x[n_] := x[n] = λ x[n - 1](1-x[n-1])


                nInf = 1000;
values = Table[x[n], {n, 0, nInf}];
n0=Floor[nInf/10];
c=0.4;
pc = Table[Sum[values[[j]]Cos[j c],{j,1,n}],{n,1,nInf}];
qc = Table[Sum[values[[j]]Sin[j c],{j,1,n}],{n,1,nInf}];


                ListPlot[Transpose[{pc,qc}], PlotRange->All, AxesLabel->{Subscript["p","c"],Subscript["q","c"]}, 
Background->Lighter[Gray], PlotStyle->Red, ImageSize->500]


                mc = Table[Sum[(pc[[j+n]]-pc[[j]])^2+(qc[[j+n]]-qc[[j]])^2,{j,1,nInf-n0}],{n,1,n0}]/(nInf-n0);
ef = Mean[values];
vosc[n_] := ef^2 (1-Cos[n c])/(1-Cos[c]);
dc[n_] := mc[[n]]-vosc[n];
dcValues = Table[dc[n],{n,1,n0}];
valuesCut = Take[values,n0];


                nValues = Table[n,{n,1,n0}];
kc = Correlation[nValues,dcValues]
kcPalio = Correlation[nValues,mc]

##### Εξαγωγή $K$


                 Clear["Global`*"]

kappa[c_, values_] := Module[
  {nInf, n0, pc, qc, mc, ef, vosc, dc, dcValues, nValues, kc},
  
  (* Αρχικοποίηση μεταβλητών *)
  nInf = Length[values] - 1;
  n0 = Floor[nInf/10];
  
  (* Υπολογισμός των pc και qc *)
  pc = Table[Sum[values[[j]] Cos[j c], {j, 1, n}], {n, 1, nInf}];
  qc = Table[Sum[values[[j]] Sin[j c], {j, 1, n}], {n, 1, nInf}];
  
  (* Υπολογισμός του mc *)
  mc = Table[
    Sum[(pc[[j + n]] - pc[[j]])^2 + (qc[[j + n]] - qc[[j]])^2, {j, 1, nInf - n0}], 
    {n, 1, n0}] / (nInf - n0);
  
  (* Υπολογισμός του μέσου όρου των values *)
  ef = Mean[values];
  
  (* Ορισμός της συνάρτησης vosc *)
  vosc[n_] := ef^2 (1 - Cos[n c]) / (1 - Cos[c]);
  
  (* Υπολογισμός του dc *)
  dc[n_] := mc[[n]] - vosc[n];
  
  (* Δημιουργία της λίστας dcValues *)
  dcValues = Table[dc[n], {n, 1, n0}];
  
  nValues = Table[n,{n,1,n0}];

  
  (* Υπολογισμός της συσχέτισης kc *)
  kc = Correlation[nValues, dcValues];
  
  (* Επιστροφή του kc *)
  kc
]


                 λ=3.95;	
x[0] = 0.123;
x[n_] := x[n] = λ x[n - 1](1-x[n-1])
nInf = 100;
values = Table[x[n], {n, 0, nInf}];


                 (* Δημιουργία 100 τυχαίων τιμών για το c στο διάστημα (0, π) *)
randomCValues = RandomReal[{0, Pi}, 100];

(* Υπολογισμός της λίστας kappa[c, values] για κάθε τυχαίο c *)
kappaList = Table[kappa[c, values], {c, randomCValues}];

(* Υπολογισμός της διάμεσου της λίστας kappaList *)
medianKappa = Median[kappaList];

(* Εμφάνιση της διάμεσου *)
medianKappa

Για μια αυτοματοποιημένη εκδοχή ορίζουμε τις συναρτήσεις:


                  Clear["Global`*"]

(* Ορισμός της συνάρτησης kappa *)
kappa[c_, values_] := Module[
  {nInf, n0, pc, qc, mc, ef, vosc, dc, dcValues, nValues, kc},
  
  (* Αρχικοποίηση μεταβλητών *)
  nInf = Length[values] - 1;
  n0 = Floor[nInf/10];
  
  (* Υπολογισμός των pc και qc *)
  pc = Table[Sum[values[[j]] Cos[j c], {j, 1, n}], {n, 1, nInf}];
  qc = Table[Sum[values[[j]] Sin[j c], {j, 1, n}], {n, 1, nInf}];
  
  (* Υπολογισμός του mc *)
  mc = Table[
    Sum[(pc[[j + n]] - pc[[j]])^2 + (qc[[j + n]] - qc[[j]])^2, {j, 1, nInf - n0}], 
    {n, 1, n0}] / (nInf - n0);
  
  (* Υπολογισμός του μέσου όρου των values *)
  ef = Mean[values];
  
  (* Ορισμός της συνάρτησης vosc *)
  vosc[n_] := ef^2 (1 - Cos[n c]) / (1 - Cos[c]);
  
  (* Υπολογισμός του dc *)
  dc[n_] := mc[[n]] - vosc[n];
  
  (* Δημιουργία της λίστας dcValues *)
  dcValues = Table[dc[n], {n, 1, n0}];
  
  nValues = Table[n, {n, 1, n0}];
  
  (* Υπολογισμός της συσχέτισης kc *)
  kc = Correlation[nValues, dcValues];
  
  (* Επιστροφή του kc *)
  kc
]

(* Ορισμός της συνάρτησης medianKappa *)
medianKappa[values_] := Module[
  {randomCValues, kappaList},
  
  (* Δημιουργία 100 τυχαίων τιμών για το c στο διάστημα (0, π) *)
  randomCValues = RandomReal[{0, Pi}, 100];
  
  (* Υπολογισμός της λίστας kappa[c, values] για κάθε τυχαίο c *)
  kappaList = Table[kappa[c, values], {c, randomCValues}];
  
  (* Υπολογισμός και επιστροφή της διάμεσου της λίστας kappaList *)
  Median[kappaList]
]


                  (* Παράδειγμα χρήσης *)
λ = 3.55;	
x[0] = 0.123;
x[n_] := x[n] = λ x[n - 1] (1 - x[n - 1]);
nInf = 1000;
values = Table[x[n], {n, 0, nInf}];

(* Κλήση της συνάρτησης medianKappa *)
result = medianKappa[values];

(* Εμφάνιση του αποτελέσματος *)
result

#### Εκθέτης Lyapunov Ορισμός της λογιστικής απεικόνισης


                    logisticMap[r_, x_] := r x (1 - x)

Υπολογισμός του εκθέτη Lyapunov για κάθε r


                     lyapunovExponent[r_, x0_, n_] := Module[{x = x0, sum = 0},
  Do[
    x = logisticMap[r, x];
    sum += Log[Abs[r (1 - 2 x)]];
    , {i, n}];
  sum/n
]

Παράμετροι


                      rMin = 3.5;
rMax = 4.0;
numPoints = 1000;
nIter = 1000; (* Αριθμός επαναλήψεων για να αγνοήσουμε το αρχικό transience *)
nLyap = 500; (* Αριθμός επαναλήψεων για τον υπολογισμό του Lyapunov *)

Υπολογισμός των εκθετών Lyapunov.


                       rValues = Range[rMin, rMax, (rMax - rMin)/numPoints];
lyapValues = Table[lyapunovExponent[r, 0.5, nLyap], {r, rValues}];

Γράφημα


                        pl=ListLinePlot[Transpose[{rValues, lyapValues}],
  AxesLabel -> {"λ", "Lyapunov Exponent"},
  PlotRange -> All,
  GridLines -> Automatic,
  Epilog -> {Dashed, Line[{{rMin, 0}, {rMax, 0}}]},
  Background -> Lighter[Gray]]

#### Εύρεση ακολουθίας ##### Από μια λίστα αριθμών


                          Clear["Global`*"]
FindSequenceFunction[{1, 1, 2, 3, 5, 8, 13}, n]
FindSequenceFunction[Table[{2 n, 2^n}, {n, 10}], n]

##### Από αναδρομικό τύπο


                           eq = a[n + 1] == 2 a[n] + 1;
init = a[0] == 1;
RSolve[eq, a[n], n]
RSolve[{eq, init}, a[n], n]

##### Συστήματα


                            eq1 = a[n + 1] == a[n] - b[n] + 1;
eq2 = b[n + 1] == a[n] + b[n] - 2;
RSolve[{eq1, eq2}, {a[n], b[n]}, n]


                            Clear["Global`*"]
eqA = a[n + 1] == A*AA*a[n] + r*DA*d[n]
eqD = d[n + 1] == A*AD*a[n] + r*DD*d[n]
AD = 1 - AA
DD = 1 - DA
r = 1
A = 1
RSolve[{eqA, a[0] == a0, eqD, d[0] == d0}, {a[n], d[n]}, n]

Απεικόνιση ακολουθίας

Ορισμός ακολουθίας


                             Clear["Global`*"]
a[1] = 1;
a[n_] := a[n] = (2 n)/(n - 1) + a[n - 1]

Λίστα σημείων


                              table1 = Table[a[n], {n, 1, 20}];
table2 = Table[{a[n], a[n + 1] - 5 a[n]}, {n, 1, 10}];

Βασικό γράφημα


                               ListPlot[table1]
ListPlot[table2]

#### Παρουσίαση πλαισίου


                                ListPlot[table1, PlotTheme -> "Scientific"]
ListPlot[table1, PlotTheme -> "Detailed"]
ListPlot[table1, PlotTheme -> "Classic"]

#### Γραμμές ως πάνω Από τον οριζόντιο άξονα.


                                  ListPlot[table1, Filling -> Axis]

Μεταξύ δύο ακολουθιών


                                   data1 = Sqrt[Range[40]] - 2;
data2 = Log[Range[40]];
ListPlot[{data1, data2}, Filling -> {1 -> {{2}, {Red, Blue}}}]

Σειρές


                                   Clear["Global`*"]
Sum[1/2^i, {i, 1, n}]
Sum[x^n, {n, 0, Infinity}]
Sum[x^n, {n, 0, Infinity}, GenerateConditions -> True]
Sum[1/i^2, {i, 1, Infinity}]

Γινόμενα


                                   Clear["Global`*"]
Product[1/2^i, {i, 1, n}]
Product[(1 + 1/2^i), {i, 1, Infinity}]